(in-package :webwidgets)

(defun transform-file (in-filename out-filename
		       &key indent (static-prefix ""))
  (with-open-file (file in-filename)
    (with-open-file (outfile out-filename
			     :direction :output
			     :if-exists :supersede)
      (write-xml (transform (parse file :compress-whitespace nil)
			    :static-prefix static-prefix)
		 outfile :indent indent))))

(eval-when ()
  (transform-file "note.ww" "note2.html")
  (transform-file "tabbox.ww" "tabbox2.html")
  (transform-file "/root/lisp/webwidgets/doc/note.ww"
		  "/root/lisp/webwidgets/doc/note.html" :static-prefix "../"))

;; Global state maintenence
;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *global-cleanup-callbacks* '()
  "List of functions that are called in no particular order to clean
up (i.e. delete) the global state.")

(defmacro defcleanup (name args &body body)
  "Define a cleanup function, which is automatically added to
*GLOBAL-CLEANUP-CALLBACKS*. It will normally be called with no
arguments, but it can specify optional and keyword arguments."
  `(progn
    (defun ,name ,args
      ,@body)
    (pushnew ',name *global-cleanup-callbacks*)))

(defun cleanup ()
  "Clean up the global state by calling the registered cleanup
callback functions in *GLOBAL-CLEANUP-CALLBACKS*."
  (mapc #'funcall *global-cleanup-callbacks*))

;; Tag dispatching
;;;;;;;;;;;;;;;;;;

(defparameter *tags-table* (make-hash-table :test #'equalp)
  "Hash table mapping tag names to transformation functions")

(defgeneric transform-node (node)
  (:documentation "Return a transformed version of the given node, and
perform whatever side-effects may be necessary."))

;; This should be overridden for any valid node types
(defmethod transform-node (node)
  (restart-case (error 'invalid-node :datum node)
    (use-value (value)
      :report "Provide a new value to return instead"
      value)
    (convert-to-string ()
      :report "Convert the node to a string and transform it"
      (transform-node (repr node)))))

(defmethod transform-node ((node string))
  node)

(defmethod transform-node ((node list))
  (multiple-value-bind (value foundp)
      (gethash (node-name node) *tags-table*)
    (if foundp
	(transform-node (funcall value node))
	(make-node :name (node-name node)
		   :ns (node-ns node)
		   :attrs (node-attrs node)
		   :children (mapcar #'transform-node
				     (node-children node))))))

(defvar *static-prefix* ""
  "Prefix prepended to addresses of static files which are included in
output")

(defun transform (tree &key (static-prefix ""))
  "Top-level transform function, which clears all relevant global
state and then transforms a tree, leaving any global state generated
in the process. This should be called on a top-level HTML tree. That
is, the node it is called on should be named 'html', and it should be
decent HTML with a head and a body. This can be destructive."
  (cleanup)
  (let ((*static-prefix* static-prefix))
    (handler-bind ((invalid-node #'convert-to-string))
      (add-scripts-and-css (transform-node tree)))))

(defmacro deftransform (name (attrs children) &body body)
  (let ((node (gensym "node")))
    `(progn
      (defun ,name (,node)
	(let ((,attrs (node-attrs ,node))
	      (,children (node-children ,node)))
	  ,@body))
      (setf (gethash ,(string name) *tags-table*) ',name))))

;; Symbol generation
;;;;;;;;;;;;;;;;;;;;

(defvar *ww-gensym-counter* 1)

(defun ww-gensym (&optional (thing "G"))
  (prog1 (format nil "~A~D" thing *ww-gensym-counter*)
    (incf *ww-gensym-counter*)))

(defcleanup reset-ww-gensym-counter (&optional (value 1))
  (setf *ww-gensym-counter* value))

;; Utility functions
;;;;;;;;;;;;;;;;;;;;

(defun attr-cons (name value attrs)
  "Non-destructively cons a name/value pair onto an attribute list,
replacing any previous value. This is not case-sensitive."
  (aif (find name attrs
	     :key #'first
	     :test #'equalp)
       (cons (car (js/css-attr-join (list name value) it))
	     (remove name attrs
		     :key #'first
		     :test #'equalp))
       (cons (list name value)
	     (remove name attrs
		     :key #'first
		     :test #'equalp))))

(defun attr-append (attrs1 attrs2)
  "Nondestructively update the second attribute list with the first,
using ATTR-CONS."
  (let ((result attrs2))
    (dolist (attr attrs1)
      (destructuring-bind (name value) attr
	(setf result (attr-cons name value result))))
    result))

(defun get-attr (name attrs)
  "Get the value of an attribute called NAME"
  (second (find name attrs :key #'first :test #'equalp)))

(defun remove-attr (name attrs)
  "Remove an attribute from an attr list"
  (remove name attrs :key #'first :test #'equalp))

(defun get-child (name children)
  "Return the first child in CHILDREN which is called NAME"
  (find name (remove-if-not #'listp children)
	:key #'first :test #'equalp))

(defun get-children (name children)
  "Return all children in CHILDREN which are called NAME"
  (remove-if-not #'(lambda (x) (equalp x name))
		 (remove-if-not #'listp children)
		 :key #'first))

(defun concat (&rest strings)
  "Concatenate arguments into a string"
  (apply #'concatenate 'string
	 (mapcar #'string strings)))

;; Adding scripts and CSS
;;;;;;;;;;;;;;;;;;;;;;;;;

;; Features

(defparameter *ww-features* '()
  "A list of features the current web page requires")

(defcleanup clear-ww-features ()
  (setf *ww-features* nil))

(defun ww-require (feature)
  (pushnew feature *ww-features*))

(defvar *requirements* nil
  "Pointer to hash table currently being used for requirement storage
for JS or CSS")

;; JS and CSS requirements of features

(defun jscss-requirements (feature)
  "Get the requirements of a feature"
  (values (gethash feature *requirements*)))

(defun jscss-require (feature &rest urls)
  (let ((requirements (union urls (jscss-requirements feature)
			     :test #'equalp)))
    (setf (gethash feature *requirements*) requirements)))

(defun get-jscss-files (&optional (features *ww-features*))
  "Return a list of URLs of files required by the features
list FEATURES (defaults to *WW-FEATURES*)."
  (when features
    (reduce #'(lambda (x y) (union x y :test #'equalp))
	    (mapcar #'jscss-requirements features))))

(defmacro define-curried-requirements-fun (newname oldname var)
  (let ((args (gensym "args")))
    `(defun ,newname (&rest ,args)
      (let ((*requirements* ,var))
	(apply #',oldname ,args)))))

;; JS-specific functions

(defvar *js-requirements* (make-hash-table)
  "A hash table mapping features to lists of JS file URLs which they
require.")

(define-curried-requirements-fun js-requirements jscss-requirements
  *js-requirements*)

(define-curried-requirements-fun js-require jscss-require
  *js-requirements*)

(define-curried-requirements-fun get-js-files get-jscss-files
  *js-requirements*)

;; CSS-specific functions

(defvar *css-requirements* (make-hash-table)
  "A hash table mapping features to lists of CSS file URLs which they
require.")

(define-curried-requirements-fun css-requirements jscss-requirements
  *css-requirements*)

(define-curried-requirements-fun css-require jscss-require
  *css-requirements*)

(define-curried-requirements-fun get-css-files get-jscss-files
  *css-requirements*)

;; XML tree manipulation

(defun add-scripts-and-css (tree)
  "Modifies TREE, adding links to all required JS and CSS files and
returning the new tree"
  (let ((head (get-child "head" (node-children tree))))
    (dolist (file (get-js-files))
      (push `("script" (("type" "text/javascript")
			("src" ,(concat *static-prefix* file))))
	    (node-children head)))
    (dolist (file (get-css-files))
      (push `("link" (("type" "text/css")
		      ("href" ,(concat *static-prefix* file))
		      ("rel" "stylesheet")))
	    (node-children head))))
  tree)

;; JS and CSS attribute joining

(defun add-trailing-semicolon-if-needed (string)
  "If the string doesn't end with a semicolon, add one."
  (if (eql (elt string (1- (length string)))
	   #\;)
      string
      (concat string ";")))

(defparameter *valid-js/css-attrs* '("style" "onAbort" "onBlur" "onChange" "onClick" "onDblClick" "onDragDrop" "onError" "onFocus" "onKeyDown" "onKeyPress" "onKeyUp" "onLoad" "onMouseDown" "onMouseMove" "onMouseOut" "onMouseOver" "onMouseUp" "onMove" "onReset" "onResize" "onSelect" "onSubmit" "onUnload")
  "List of attributes which contain JavaScript or CSS code")

(defun valid-js/css-attr (key)
  "Does the attribute named KEY contain JavaScript or CSS code?"
  (find key *valid-js/css-attrs*
	:test #'equalp))

(defun js/css-attr-join (attr1 attr2)
  "Given two atributes which contain JavaScript or CSS code, return a
list of either one or two attributes, with the attributes joined into
one if they have the same name."
  (destructuring-bind ((key1 val1) . (key2 val2)) (cons attr1 attr2)
    (if (and (equalp key1 key2)
	     (valid-js/css-attr key1))
	(list key1 (format nil "~A ~A"
			   (add-trailing-semicolon-if-needed val1)
			   (add-trailing-semicolon-if-needed val2)))
	(list attr1 attr2))))

(js/css-attr-join '("onclick" "style.color = 'red'")
		  '("onclick" "style.border = 'medium dashed green'"))

(js/css-attr-join '("style" "color: red;")
		  '("style" "border: medium dashed green"))

;; Note transformer
;;;;;;;;;;;;;;;;;;;

(progn
  (js-require :note "note.js")
  (css-require :note "note.css"))

(deftransform note (attrs children)
  (ww-require :note)
  (let ((id (or (get-attr "id" attrs)
		(ww-gensym "ww_note")))
	(small (or (get-child "small" children)
		   '("small" () "Note")))
	(full (or (get-child "full" children)
		  (warn "In <note> tag, <full> was not given."))))
    `("span" ,(attr-append `(("class" "ww_note")
			     ("id" ,id))
			   attrs)
      ("span" ,(attr-append `(("class" "ww_note_small")
			      ("id" ,(concat id "_small"))
			      ("onclick" ,(format nil "ww_note_toggle('~A')"
						  id)))
			    (node-attrs small))
       ,@(node-children small))
      ("span" ,(attr-append `(("class" "ww_note_full")
			      ("id" ,(concat id "_full")))
			    (node-attrs full))
       ,@(node-children full)))))

;; Tabbox transformer
;;;;;;;;;;;;;;;;;;;;;

(progn
  (js-require :tabbox "tabbox.js")
  (css-require :tabbox "tabbox.css"))

(defun make-tabbox-bar (id tabs)
  "Given the id of the tabbox and a list of tabs, return the bar at
the top of the tabbox."
  `("span" (("class" "ww_tabbox_bar")
	    ("id" ,(concat id "_bar")))
    ,@(loop for tab in tabs
	    for tab-number upfrom 1
	    collect `("span" (("class" "ww_tabbox_tab")
			      ("onclick" ,(format nil "ww_setTab('~A', ~D)"
						  id tab-number))
			      ("id" ,(format nil "~A_tab~D" id tab-number))
			      ,@(when (= tab-number 1)
				      '(("style" "padding-bottom: 1px; font-weight: bold;"))))
		      ,(get-attr "title" (node-attrs tab))))))

(defun make-tabbox-tab (id tab tab-number)
  "Make a tab in a tabbox given the tabbox id; the tab; and the number
of the tab, starting from 1."
  `("div" ,(attr-append `(("class" "ww_tabbox_pane")
			  ("id" ,(format nil "~A_pane~D" id tab-number))
			  ,@(if (= tab-number 1)
				'(("style" "display: block"))))
			(remove-attr "title" (node-attrs tab)))
    ,@(node-children tab)))

(deftransform tabbox (attrs children)
  (ww-require :tabbox)
  (let* ((id (or (get-attr "id" attrs)
		 (ww-gensym "ww_tabbox")))
	 (tabs (get-children "tab" children))
	 (tabbox-bar (make-tabbox-bar id tabs)))
    `("div" (("class" "ww_tabbox")
	     ("id" ,id))
      ,tabbox-bar
      ,@(loop for tab in tabs
	      for tab-number upfrom 1
	      collect (make-tabbox-tab id tab tab-number)))))